(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

(* FIX: Consider getting rid of this code entirely and using only "non-Metafont" fonts. *)

open FontMetric
open GlyphMetric
open Substitute
open UniTools
open XNum  
  
let rec read_nybbles ic len =
  if len = 0 then
    []
  else
    (let c = IO.read_be_u8 ic
     in (c / 16) :: (c mod 16) :: (read_nybbles ic (len - 1)))
  
let read_packed_num dyn_f nybbles =
  match nybbles with
  | [] -> (0, [])
  | i :: ns ->
      if i = 0
      then
        (let rec skip_zero i nyb =
           match nyb with
           | [] -> (0, [])
           | n :: ns ->
               if n = 0
               then skip_zero (i + 1) ns
               else
                 (let rec read_digits len num nyb =
                    if len > 0
                    then
                      (match nyb with
                       | [] -> read_digits (len - 1) (16 * num) []
                       | n :: ns -> read_digits (len - 1) ((16 * num) + n) ns)
                    else ((((num - 15) + (16 * (13 - dyn_f))) + dyn_f), nyb)
                  in read_digits i n ns)
         in skip_zero 1 ns)
      else
        if i <= dyn_f
        then (i, ns)
        else
          if i < 14
          then
            (match ns with
             | [] -> ((((16 * ((i - dyn_f) - 1)) + dyn_f) + 1), [])
             | m :: ms ->
                 (((((16 * ((i - dyn_f) - 1)) + m) + dyn_f) + 1), ms))
          else ((-1), nybbles)
  
(* repeat command *)
let rec skip_specials ic =
  let x = IO.read_be_u8 ic
  in
    if x < 0
    then x
    else
      if x = 240
      then (IO.skip ic (IO.read_be_u8 ic); skip_specials ic)
      else
        if x = 241
        then (IO.skip ic (IO.read_be_u16 ic); skip_specials ic)
        else
          if x = 242
          then (IO.skip ic (IO.read_be_u24 ic); skip_specials ic)
          else
            if x = 243
            then
              (IO.skip ic (int_of_num (IO.read_be_u32 ic)); skip_specials ic)
            else
              if x = 244
              then (IO.skip ic 5; skip_specials ic)
              else
                if x = 245
                then (-1)
                else if x = 246 then skip_specials ic else x
  
let parse_glyph glyph dyn_f width height paint_switch nybbles =
  (if dyn_f = 14
   then
     (let rec iter i nybbles =
        let set_points p1 p2 p3 p4 =
          (if p1
           then
             BitmapBase.set_point glyph.GlyphBitmap.g_bitmap (i mod width)
               (i / width)
           else ();
           if p2
           then
             BitmapBase.set_point glyph.GlyphBitmap.g_bitmap ((i + 1) mod width)
               ((i + 1) / width)
           else ();
           if p3
           then
             BitmapBase.set_point glyph.GlyphBitmap.g_bitmap ((i + 2) mod width)
               ((i + 2) / width)
           else ();
           if p4
           then
             BitmapBase.set_point glyph.GlyphBitmap.g_bitmap ((i + 3) mod width)
               ((i + 3) / width)
           else ())
        in
          ((match List.hd nybbles with
              | 1 -> set_points false false false true
              | 2 -> set_points false false true false
              | 3 -> set_points false false true true
              | 4 -> set_points false true false false
              | 5 -> set_points false true false true
              | 6 -> set_points false true true false
              | 7 -> set_points false true true true
              | 8 -> set_points true false false false
              | 9 -> set_points true false false true
              | 10 -> set_points true false true false
              | 11 -> set_points true false true true
              | 12 -> set_points true true false false
              | 13 -> set_points true true false true
              | 14 -> set_points true true true false
              | 15 -> set_points true true true true
              | _ -> ());
           iter (i + 4) (List.tl nybbles))
      in iter 0 nybbles)
   else
     (let rec iter i x rows_left paint_switch repeat_count nybbles =
        let rec set_points i n =
          if n > 0
          then
            (BitmapBase.set_point glyph.GlyphBitmap.g_bitmap (i mod width)
               (i / width);
             set_points (i + 1) (n - 1))
          else () in
        let copy_lines i n =
          let rec iter y n =
            if n > 0
            then
              (BitmapBase.copy_line glyph.GlyphBitmap.g_bitmap (y - 1) y;
               iter (y + 1) (n - 1))
            else ()
          in iter (i / width) n
        in
          if rows_left > 0
          then
            (let (count, nyb) = read_packed_num dyn_f nybbles
             in
               if count < 0
               then
                 if (List.hd nyb) = 15
                 then iter i x rows_left paint_switch 1 (List.tl nyb)
                 else
                   (let (count, nybbles) =
                      read_packed_num dyn_f (List.tl nyb)
                    in iter i x rows_left paint_switch count nybbles)
               else
                 if (x + count) >= width
                 then
                   (let n = width - x
                    in
                      (if paint_switch then set_points i n else ();
                       copy_lines (i + n) repeat_count;
                       if paint_switch
                       then
                         set_points ((i + n) + (repeat_count * width))
                           (count - n)
                       else ();
                       iter ((i + count) + (repeat_count * width))
                         ((x + count) mod width)
                         ((rows_left - repeat_count) - ((x + count) / width))
                         (not paint_switch) 0 nyb))
                 else
                   (if paint_switch then set_points i count else ();
                    iter (i + count) (x + count) rows_left (not paint_switch)
                      repeat_count nyb))
          else ()
      in iter 0 0 height paint_switch 0 nybbles);
   glyph)
  
let read_glyph ic fm (hppp, vppp, _) glyphs =
  let read_preamble low_bits =
    if low_bits = 7
    then
      (let len = (int_of_num (IO.read_be_u32 ic)) - 28 in
       let char = int_of_num (IO.read_be_u32 ic) in
       let tfm = IO.read_be_u32 ic in
       let dx = div_num (IO.read_be_u32 ic) (num_of_int 0x10000) in
       let dy = div_num (IO.read_be_u32 ic) (num_of_int 0x10000) in
       let w = int_of_num (IO.read_be_u32 ic) in
       let h = int_of_num (IO.read_be_u32 ic) in
       let hoff = int_of_num (IO.read_be_i32 ic) in
       let voff = int_of_num (IO.read_be_i32 ic)
       in (len, char, tfm, dx, dy, w, h, hoff, voff))
    else
      if low_bits > 3
      then
        (let len = ((0x10000 * (low_bits - 4)) + (IO.read_be_u16 ic)) - 13 in
         let char = IO.read_be_u8 ic in
         let tfm = num_of_int (IO.read_be_u24 ic) in
         let dx = num_of_int (IO.read_be_u16 ic) in
         let dy = num_zero in
         let w = IO.read_be_u16 ic in
         let h = IO.read_be_u16 ic in
         let hoff = IO.read_be_i16 ic in
         let voff = IO.read_be_i16 ic
         in (len, char, tfm, dx, dy, w, h, hoff, voff))
      else
        (let len = ((0x100 * low_bits) + (IO.read_be_u8 ic)) - 8 in
         let char = IO.read_be_u8 ic in
         let tfm = num_of_int (IO.read_be_u24 ic) in
         let dx = num_of_int (IO.read_be_u8 ic) in
         let dy = num_zero in
         let w = IO.read_be_u8 ic in
         let h = IO.read_be_u8 ic in
         let hoff = IO.read_be_i8 ic in
         let voff = IO.read_be_i8 ic
         in (len, char, tfm, dx, dy, w, h, hoff, voff)) in
  let flag_byte = skip_specials ic in
  let dyn_f = flag_byte / 16 in
  let paint_switch = (flag_byte mod 16) > 7 in
  let low_bits = flag_byte mod 8
  in
    if flag_byte = 245
    then ()
    else
      (let (len, char, _, _, _, width, height, h_off, v_off) =
         read_preamble low_bits in
       let nybbles = read_nybbles ic len in
       let gm = get_glyph_metric fm (Simple char)
       in
         glyphs.(char) <-
           parse_glyph
           (GlyphBitmap.make char
              (int_of_num (round_num (mult_num gm.gm_width hppp)))
              (int_of_num (round_num (mult_num gm.gm_height vppp)))
              (int_of_num (round_num (mult_num gm.gm_depth vppp)))
              (float_of_num hppp) (float_of_num vppp)
              ((- h_off), ((v_off - height) - 1))
              (((width - h_off) - 1), v_off))
           dyn_f width height paint_switch nybbles)
  
let read_preamble ic =
  let pre = IO.read_be_u8 ic in
  let id = IO.read_be_u8 ic
  in
    if (pre <> 247) || (id <> 89)
    then None
    else
      (let comment_len = IO.read_be_u8 ic
       in
         (IO.skip ic comment_len;
          (* comment *)
          let design_size = div_num (IO.read_be_u32 ic) (num_of_int 0x100000)
          in
            (IO.skip ic 4;
             (* checksum *)
             let hppp = div_num (IO.read_be_u32 ic) (num_of_int 0x10000) in
             let vppp = div_num (IO.read_be_u32 ic) (num_of_int 0x10000)
             in Some ((hppp, vppp, design_size)))))
  
let parse_pk_file fm ic =
  match read_preamble ic with
    | None -> None
    | Some resolution ->
        let glyphs =
          Array.make ((fm.last_glyph - fm.first_glyph) + 1) GlyphBitmap.empty_glyph
        in
          ((try
              while not (IO.eof ic) do read_glyph ic fm resolution glyphs done
            with | _ -> ());
           Some ((resolution, glyphs)))
  
let read_pk_font fm dpi =
  let filename = KPathSea.find_glyph fm.name dpi in
    match filename with
      | "" -> None
      | fn ->
          try
            parse_pk_file fm (IO.make_in_stream (UniText.of_string fn))
          with
            | _ -> None
